home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-11 / rlib.zip / RL_BOXME.PRG < prev    next >
Text File  |  1993-01-04  |  6KB  |  179 lines
  1. * Function..: BOXMENU
  2. * Author....: Richard Low
  3. * Syntax....: BOXMENU( row, column, options [,choice [,altkeys [,exitkeys
  4. *                      [,prompts [,prompt_row [,colors ]]]]]]] )
  5. * Returns...: Number of array element option picked, or 0 if escape pressed.
  6. * Parameters: row       - Top row to start box menu
  7. *             column    - Top left column of menu box
  8. *             options   - Array of menu option choices
  9. *             choice    - Optional starting array element number
  10. *             altkeys   - Optional list of alternate selection keys
  11. *             exitkeys  - Optional list of keys to cause a 0 return value exit
  12. *                         Pass a null string to skip (default = escape)
  13. *                         Pass .F. to disable 0 return value exit altogether
  14. *             prompts   - Optional array of menu option messages
  15. *             promptrow - Optional row number on which these messages appear
  16. *             colors    - Optional character string of colors to use in menu
  17. * Notes.....: If an optional parameters is skipped, you must pass a dummy in
  18. *             its place.
  19.  
  20. FUNCTION BOXMENU
  21.  
  22. PARAMETERS p_row, p_col, p_options, p_choice, p_altkeys, p_exitkeys,;
  23.            p_prompts, p_prmtrow, p_colors
  24.  
  25. PRIVATE f_prompton, f_incolor, f_maxwide, f_junk, f_canexit, f_x, f_lkey,;
  26.         f_display, f_menubar, f_box_on, f_box_off, f_selected
  27.  
  28.  
  29. *-- check that first 3 parameters are passed and correct type
  30. IF TYPE('p_row') + TYPE('p_col') + TYPE('p_options') != 'NNA'
  31.    RETURN 0
  32. ENDIF
  33.  
  34.  
  35. *-- see if row,column is in range, if not, default to row,column 1,1
  36. p_row = IF( p_row > 24, 1, p_row )
  37. p_col = IF( p_col > 79, 1, p_col )
  38.  
  39.  
  40. *-- if p_choice specified make sure it is in range, else default to option 1
  41. p_choice = IF( TYPE('p_choice') = 'N', MIN(MAX(p_choice,1),LEN(p_options)), 1 )
  42.  
  43.  
  44. *-- messages displayed only if parm is of type array
  45. f_prompton = ( TYPE('p_prompts') = 'A' )
  46.  
  47. *-- messages displayed on line 24 unles otherwise specified
  48. p_prmtrow = IF( TYPE('p_prmtrow') = 'N', p_prmtrow, 24 )
  49.  
  50.  
  51. *-- save incoming color
  52. STORE SETCOLOR() TO f_incolor
  53.  
  54. *-- use <color array> if it is an array AND it has at least 5 elements
  55. IF IF( TYPE('p_colors') = 'A', IF(LEN(p_colors) >= 5, .T., .F.) , .F. )
  56.    f_display  = p_colors[1]                    && display color
  57.    f_menubar  = p_colors[2]                    && menu bar color
  58.    f_box_on   = p_colors[3]                    && active box color
  59.    f_box_off  = p_colors[4]                    && box border after exit
  60.    f_selected = p_colors[5]                    && selected option color
  61. ELSE
  62.    STORE SETCOLOR() TO f_display, f_box_off
  63.    STORE BRIGHT() TO f_box_on, f_selected
  64.    f_menubar  = GETPARM(2,f_incolor)
  65. ENDIF
  66.  
  67.  
  68. *-- change column number to one to right of the box to avoid lots of math
  69. p_col = p_col + 1
  70.  
  71. *-- display options, find max width, and build list of first letter pick keys
  72. f_junk = ''
  73. f_maxwide = 1
  74. SETCOLOR(f_display)
  75. FOR f_x = 1 TO LEN(p_options)
  76.    @ p_row+f_x,p_col SAY p_options[f_x]
  77.    f_maxwide = MAX( f_maxwide, LEN(p_options[f_x]) )
  78.    f_junk = f_junk + SUBSTR( LTRIM(p_options[f_x]),1,1 )
  79. NEXT f_x
  80.  
  81. *-- now draw the box for the menu using the maximum width of options
  82. *-- making the active box a double line box
  83. SETCOLOR(f_box_on)
  84. @ p_row, p_col-1, p_row+LEN(p_options)+1, p_col+f_maxwide BOX '╔═╗║╝═╚║'
  85.  
  86. *-- now add any alternate pick keys passed as parameters to the list, if any
  87. p_altkeys = IF( TYPE('p_altkeys') = 'C', f_junk + p_altkeys, f_junk )
  88.  
  89. *-- if a Logical was passed in place of exit keys, disable exit feature
  90. f_canexit = IF( TYPE('p_exitkeys') = 'L', p_exitkeys, .T. )
  91.  
  92. *-- see if any exit keys were passed (and not empty), else default to Escape
  93. p_exitkeys = IF( TYPE('p_exitkeys') = 'C', p_exitkeys, CHR(27) )
  94. p_exitkeys = IF( .NOT. EMPTY(p_exitkeys),  p_exitkeys, CHR(27) )
  95.  
  96. DO WHILE .T.
  97.  
  98.    *-- display current selection in desired highlite video
  99.    SETCOLOR(f_menubar)
  100.    @ p_row+p_choice,p_col SAY p_options[p_choice]
  101.  
  102.    *-- if message prompts are on, clear row and display
  103.    IF f_prompton
  104.       SETCOLOR(f_incolor)
  105.       @ p_prmtrow,0
  106.       @ p_prmtrow,(80-LEN(p_prompts[p_choice]))/2 SAY p_prompts[p_choice]
  107.    ENDIF
  108.  
  109.    *-- reset display color
  110.    SETCOLOR(f_display)
  111.  
  112.    *-- wait for a key
  113.    f_lkey = INKEY(0)
  114.  
  115.    DO CASE
  116.  
  117.       CASE f_lkey = 24
  118.          *-- Down Arrow
  119.          @ p_row+p_choice,p_col SAY p_options[p_choice]
  120.          p_choice = IF( p_choice = LEN(p_options), 1, p_choice + 1 )
  121.  
  122.       CASE f_lkey = 5
  123.          *-- Up Arrow or Back Space
  124.          @ p_row+p_choice,p_col SAY p_options[p_choice]
  125.          p_choice = IF( p_choice = 1, LEN(p_options), p_choice - 1 )
  126.  
  127.       CASE f_lkey = 1
  128.          *-- Home Key
  129.          @ p_row+p_choice,p_col SAY p_options[p_choice]
  130.          p_choice = 1
  131.  
  132.       CASE f_lkey = 6
  133.          *-- End key
  134.          @ p_row+p_choice,p_col SAY p_options[p_choice]
  135.          p_choice = LEN(p_options)
  136.  
  137.       CASE f_lkey = 13
  138.          *-- Enter key
  139.          EXIT
  140.  
  141.       CASE UPPER(CHR(f_lkey)) $ p_altkeys
  142.          @ p_row+p_choice,p_col SAY p_options[p_choice]
  143.          f_x = 1
  144.          p_choice = 0
  145.          DO WHILE p_choice = 0
  146.             p_choice = AT(UPPER(CHR(f_lkey)),SUBSTR(p_altkeys,f_x,LEN(p_options)))
  147.             f_x = f_x + LEN(p_options)
  148.          ENDDO
  149.          EXIT
  150.  
  151.       CASE f_canexit
  152.          IF UPPER(CHR(f_lkey)) $ p_exitkeys
  153.             *-- Escape request
  154.             p_choice = 0
  155.             EXIT
  156.          ENDIF
  157.  
  158.    ENDCASE
  159. ENDDO
  160.  
  161. *-- display selected option in selected color
  162. IF p_choice > 0 .AND. p_choice <= LEN(p_options)
  163.    SETCOLOR(f_selected)
  164.    @ p_row+p_choice,p_col SAY p_options[p_choice]
  165.    *-- redraw box in in-active box color
  166.    SETCOLOR(f_box_off)
  167.    @ p_row, p_col-1, p_row+LEN(p_options)+1, p_col+f_maxwide BOX '┌─┐│┘─└│'
  168. ENDIF
  169.  
  170. *-- restore original color
  171. SETCOLOR(f_incolor)
  172.  
  173. *-- clear message line
  174. IF f_prompton
  175.    @ p_prmtrow,0
  176. ENDIF
  177.  
  178. RETURN p_choice
  179.